home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _dec5d9f17be37b809b4e37a910ea435d < prev    next >
Encoding:
Text File  |  2002-05-01  |  4.2 KB  |  138 lines
  1. package PPM::Repository::PPMServer;
  2.  
  3. use strict;
  4. use PPM::PPD;
  5. use PPM::Search;
  6. use PPM::Result qw(Ok Error Warning List);
  7. use base qw(PPM::Repository);
  8. use vars qw($VERSION @ISA);
  9.  
  10. use Data::Dumper;
  11.  
  12. $VERSION = '3.05';
  13.  
  14. #=============================================================================
  15. # Note: The server appears to expose this interface:
  16. # search_ppds('archname', 'package', 'searchtag')
  17. # fetch_ppd('package')
  18. # fetch_summary()
  19. # packages()
  20. #=============================================================================
  21.  
  22. # The server-side search function only supports totally gay queries:
  23. sub search {
  24.     my $o = shift;
  25.     my $target = shift;
  26.     my $qstring = $o->mod_to_pkg(shift);
  27.     my ($q_type, $query, $searchtag) = parse_query($qstring);
  28.     my $casei = shift;
  29.  
  30.     my @ppds;
  31.     if ($q_type eq 'TRADITIONAL') {
  32.     substr($query, 0, 0) = "(?i)" if $casei;
  33.     my $archname = $target->config_get("ARCHITECTURE")->result;
  34.     my $data = eval {
  35.         $o->{client}->search_ppds($archname, $query, $searchtag)->result
  36.     };
  37.     if ($@) {
  38.         chomp $@;
  39.         return Error("server-side search failed: $@");
  40.     }
  41.     my $res = $o->parse_summary($data, $qstring);
  42.     return $res unless $res->ok;
  43.     @ppds = values %{$res->result};
  44.     }
  45.     else {
  46.     unless ($o->{full_summary}) {
  47.         my $data = eval {
  48.         $o->{client}->fetch_summary()->result
  49.         };
  50.         if ($@) {
  51.         chomp $@;
  52.         return Error("server-side summary fetch failed: $@");
  53.         }
  54.         $o->{full_summary} = $data;
  55.     }
  56.     my $res = $o->parse_summary($o->{full_summary}, 'full_summary');
  57.     return $res unless $res->ok;
  58.     my $compiled = PPM::PPD::Search->new($query, $casei);
  59.     return Error($compiled->error) unless $compiled->valid;
  60.         @ppds = $compiled->search(values %{$res->result});
  61.     }
  62.     $_->{is_complete} = 0 for @ppds;
  63.     return List(@ppds);
  64. }
  65.  
  66. sub describe {
  67.     my $o = shift;
  68.     my $target = shift;
  69.     my $pkg = $o->mod_to_pkg(shift);
  70.     my $ppd = $o->getppd($target, $pkg);
  71.     return $ppd unless $ppd->ok;
  72.     my $ppd_ref = PPM::PPD->new($ppd->result, $o, $pkg);
  73.     return Ok($ppd_ref);
  74. }
  75.  
  76. sub getppd {
  77.     my $o = shift;
  78.     my $target = shift;
  79.     my $pkg = $o->mod_to_pkg(shift);
  80.     my $ppd = eval { $o->{client}->fetch_ppd($pkg)->result };
  81.     if ($@) {
  82.     chomp $@;
  83.     return Error("server-side fetch-ppd failed: $@");
  84.     }
  85.     elsif (not $ppd) {
  86.     return Error("Package '$pkg' not found on server. "
  87.              . "Please 'search' for it first.");
  88.     }
  89.     Ok($ppd);
  90. }
  91.  
  92. sub init { }
  93. sub load_pkg { }
  94. sub type_printable { "PPMServer 2.0" }
  95.  
  96. #=============================================================================
  97. # This query parser decides what type of query we're getting: a traditional
  98. # query which searches by TITLE only, or an advanced query:
  99. #=============================================================================
  100. sub parse_query {
  101.     my $query = shift;
  102.     
  103.     # If the query is '*', return everything:
  104.     if ($query eq '*') {
  105.     # Although we could do this with TRADITIONAL, it's actually faster to
  106.     # request the whole summary, and just return it directly. It's also
  107.     # more portable: the guy at theoryx5.uwinnipeg.ca decided not to
  108.     # implement empty searches. He must have reverse-engineered the PPM
  109.     # Server.
  110.     return ('ADVANCED', '');
  111.     }
  112.     # If there are only alphanumeric characters in it:
  113.     if ($query =~ /^[-_A-Za-z0-9]+$/) {
  114.     return ('TRADITIONAL', $query);
  115.     }
  116.     # If there's only 1 field spec: i.e. NAME=foo, or TITLE=bar
  117.     if ($query =~ /^([A-Za-z]+)=([-_A-Za-z0-9]+)$/ && is_traditional($1)) {
  118.     my ($f, $q) = (uc($1), $2);
  119.     $f = 'TITLE' if $f eq 'NAME'; # Required for the server
  120.     return ('TRADITIONAL', $q, $f);
  121.     }
  122.     # If there are only alphanumeric characters, plus '*' and '.' in it,
  123.     # convert it to the same regular expression PPM::Search would use, and let
  124.     # the server do it:
  125.     if ($query =~ /^[-_A-Za-z0-9\*\.\?]+$/) {
  126.     my $re = PPM::Search::glob_to_regex($query, 0);
  127.     return ('TRADITIONAL', "$re");
  128.     }
  129.  
  130.     # Otherwise, get the whole summary and use PPM::Search
  131.     return ('ADVANCED', $query);
  132. }
  133.  
  134. sub is_traditional {
  135.     my $field = uc(shift);
  136.     return scalar grep { $field eq $_ } qw(ABSTRACT AUTHOR TITLE NAME);
  137. }
  138.